/*M* ACODE_SI6 PL6 source for the Adventure A-code interpreter */ ACODE_MAIN: PROC MAIN; DCL INITIALIZE_ACODE ENTRY ALTRET; DCL EXECUTE_ACODE ENTRY ALTRET; CALL INITIALIZE_ACODE; CALL EXECUTE_ACODE; END ACODE_MAIN; %EOD; ACODE_INTERPRETER: PROC (RECNO) ALTRET; %INCLUDE CP_6; %INCLUDE CP_6_SUBS; %INCLUDE B_ERRORS_C; %INCLUDE B$JIT; %INCLUDE ADVENTURE_C61; %F$DCB; %B$EXCFR; %B$ALT; %B$TCB (STCLASS="BASED(B$TCB$)"); %M$DCB (DCBN=F$DATABASE, ASN=FILE, NAME='CAVE_DB', FUN=IN, ACS=DIRECT); %FPT_OPEN (FPTN=OPEN_LOG_FILE, DCB=F$LOG, ASN=FILE, NAME=LOG_FILE_NAME, ACCT=DATABASE_ACCOUNT, ACCESS=LOG_FILE_ACCESS_CONTROLS, FUN=CREATE, EXIST=OLDFILE, ORG=CONSEC, DISP=NAMED, ACS=SEQUEN); %FPT_OPEN (FPTN=OPEN_DATABASE, DCB=F$DATABASE, ACCT=DATABASE_ACCOUNT); %FPT_OPEN (FPTN=OPEN_LO, DCB=M$LO, RES='ME ', FUN=CREATE); %FPT_OPEN (FPTN=OPEN_SI, DCB=M$SI, RES='ME ', FUN=IN); %FPT_READ (FPTN=READ_DATABASE, DCB=F$DATABASE, SEED=%SEED, KEY=DATABASE_KEY, KEYS=YES); %FPT_READ (FPTN=READ_SI, DCB=M$SI, BUF=COMMAND); %FPT_WRITE (FPTN=WRITE_LO, DCB=M$LO, BUF=MESSAGE); %FPT_WRITE (FPTN=WRITE_LOG_FILE, DCB=F$LOG, BUF=LOG_FILE_RECORD); %FPT_GDS (FPTN=GET_VOCAB, RESULTS=VOCAB_AREA); %FPT_GDS (FPTN=GET_INST, RESULTS=INST_AREA, SEGSIZE=1024); %FPT_GDS (FPTN=GET_DATA, RESULTS=DATA_AREA); %FPT_ERRMSG (FPTN=REPORT_ERROR, CODE=YUKK, BUF=MESSAGE, OUTDCB1=M$LO, SUBMESS=YES); %FPT_DISPLAY (RESULTS=VLR_DISPLAY); %FPT_TIME (FPTN=GET_DATE_AND_TIME, SOURCE=CLOCK, DEST=LOCAL, DATE=DATE_INFO.DATE#, DAY=DATE_INFO.DAY#, TIME=DATE_INFO.TIME#); %FPT_OPEN (FPTN=OPEN_SAVEFILE, DCB=F$SAVE, ASN=FILE, NAME=SAVEFILE_NAME, PASS=SAVEFILE_PASSWORD); %FPT_READ (FPTN=READ_SAVEFILE, DCB=F$SAVE, SEED=%SEED); %FPT_WRITE (FPTN=WRITE_SAVEFILE, DCB=F$SAVE, SEED=%SEED); %FPT_CLOSE (FPTN=CLOSE_SAVEFILE, DCB=F$SAVE); %FPT_CLOSE (FPTN=CLOSE_LOG_FILE, DCB=F$LOG, DISP=SAVE); %FPT_TRAP (ARITHMETIC=ACODE_TRAPPED, DIVIDE_CHECK=TRAP, OVERFLOW=TRAP, ERRORS=ACODE_TRAPPED, IPR=TRAP, MEMORY=TRAP, MISSING_SEG=TRAP, MISSING_PAGE=TRAP, SECURITY_1=TRAP, SECURITY_2=TRAP, PMME=ACODE_TRAPPED); %FPT_MONINFO (SITEINFO=VLR_SITEINFO); %FPT_SCON (SAVEFLG=NO); %VLR_SITEINFO; %VLP_VECTOR (FPTN=VOCAB_AREA, SEGID='0'O); %VLP_VECTOR (FPTN=INST_AREA, SEGID='0'O); %VLP_VECTOR (FPTN=DATA_AREA, SEGID='0'O); %VLP_NAME (FPTN=SAVEFILE_NAME); %VLP_NAME (FPTN=LOG_FILE_NAME); %VLP_PASS (FPTN=SAVEFILE_PASSWORD, PASS='password'); %VLP_ACCT (FPTN=DATABASE_ACCOUNT); %VLP_ATTR (FPTN=LOG_FILE_ACCESS_CONTROLS); %VLP_ACCESS (ACCT='ALL', WNEW=YES, LAST=";"); %VLR_DISPLAY; %MACRO DAY (NAME=*, ABBREV=' ', FULL=' ', BLOCK1='XXXX-XXXX', BLOCK2='XXXX-XXXX', BLOCK3='XXXX-XXXX'); DCL 1 NAME CONSTANT SYMDEF, 2 ABBREV# CHAR (4) INIT (ABBREV), 2 FULL# CHAR (12) INIT (FULL), 2 BLOCK1#, 3 START CHAR (4) INIT (%(SUBSTR(BLOCK1, 0, 4))), 3 STOP CHAR (4) INIT (%(SUBSTR(BLOCK1, 5, 4))), 2 BLOCK2#, 3 START CHAR (4) INIT (%(SUBSTR(BLOCK2, 0, 4))), 3 STOP CHAR (4) INIT (%(SUBSTR(BLOCK2, 5, 4))), 2 BLOCK3#, 3 START CHAR (4) INIT (%(SUBSTR(BLOCK3, 0, 4))), 3 STOP CHAR (4) INIT (%(SUBSTR(BLOCK3, 5, 4))); %MEND; %DAY (NAME=MONDAY, ABBREV='MON', FULL='Monday', BLOCK1='0000-0900', BLOCK2='1130-1330', BLOCK3='1700-2400'); %DAY (NAME=TUESDAY, ABBREV='TUE', FULL='Tuesday', BLOCK1='0000-0900', BLOCK2='1130-1330', BLOCK3='1700-2400'); %DAY (NAME=WEDNESDAY, ABBREV='WED', FULL='Wednesday', BLOCK1='0000-0900', BLOCK2='1130-1330', BLOCK3='1700-2400'); %DAY (NAME=THURSDAY, ABBREV='THU', FULL='Thursday', BLOCK1='0000-0900', BLOCK2='1130-1330', BLOCK3='1700-2400'); %DAY (NAME=FRIDAY, ABBREV='FRI', FULL='Friday', BLOCK1='0000-0900', BLOCK2='1130-1330', BLOCK3='1700-2400'); %DAY (NAME=SATURDAY, ABBREV='SAT', FULL='Saturday', BLOCK1='0000-2400'); %DAY (NAME=SUNDAY, ABBREV='SUN', FULL='Sunday', BLOCK1='0000-2400'); DCL RECNO UBIN; DCL RECORD UBIN; DCL IC UBIN; DCL NEXT_IC UBIN; DCL YUKK BIT(36) STATIC; DCL 1 DATABASE_KEY STATIC, 2 LEN UBIN BYTE UNAL INIT (3), 2 RECORD UBIN (27) UNAL; DCL MESSAGE CHAR (132) STATIC; DCL TEMP_MESSAGE CHAR (132) STATIC; DCL COMMAND CHAR (80) STATIC; DCL 1 HEADER_RECORD STATIC, 2 VOCAB_SIZE UBIN, 2 MAX_BUF_ENTRIES UBIN, 2 NUMBER_OF_OBJECTS UBIN, 2 NUMBER_OF_PLACES UBIN, 2 NUMBER_OF_VARIABLES UBIN; DCL 1 SAVEFILE STATIC, 2 VOCAB_SIZE UBIN, 2 MAX_BUF_ENTRIES UBIN, 2 NUMBER_OF_OBJECTS UBIN, 2 NUMBER_OF_PLACES UBIN, 2 NUMBER_OF_VARIABLES UBIN; DCL VOCAB_TEXT CHAR (HEADER_RECORD.VOCAB_SIZE) BASED (VOCAB_AREA.PTR$); DCL 1 VOCAB_ENTRY BASED (ENTRY$) UNAL, 2 PREFIX CHAR (1), 2 VALUE UBIN HALF UNAL, 2 INFIX CHAR (1), 2 NAME CHAR (13); DCL 1 A_CODE BASED (A_CODE$) ALIGNED, 2 PREFIX, 3 RECNO UBIN, 3 LLINK$ PTR, 3 RLINK$ PTR, 2 OPS (0:0) SBIN HALF UNAL; DCL INST_AREA_LENGTH UBIN STATIC INIT (0); DCL A_CODE$ PTR; DCL INST_AREA_REMAINING UBIN STATIC; DCL NEXT_INST$ PTR STATIC; DCL CACHE_FULL LOGICAL STATIC INIT (%NO#); DCL F$DATABASE$ PTR STATIC; DCL F$SAVE$ PTR STATIC; DCL XLATE_TO_LC (0:127) UBIN BYTE UNAL STATIC; DCL XLATE_TO_UC (0:127) UBIN BYTE UNAL STATIC; DCL STOP_ON_NONBLANK (0:127) UBIN BYTE UNAL CONSTANT INIT (1 * %(ASCBIN(' ')), 0, 1 * 0); DCL 1 DATE_INFO STATIC, 2 DAY# CHAR (3), 2 DATE# CHAR (8), 2 TIME# CHAR (11); DCL LOG_FILE_RECORD CHAR (80) STATIC; DCL DAY_OF_WEEK CHAR (3) STATIC; DCL HOUR_OF_DAY CHAR (4) STATIC; DCL ENTRY$ PTR; DCL B$JIT$ PTR SYMREF; DCL B$TCB$ PTR SYMREF; DCL 1 PARAMETER (0:2) STATIC, 2 TEXT CHAR (12), 2 LEN UBIN; DCL 1 VALUE_SCAN STATIC, 2 PREFIX CHAR (1) INIT ('$'), 2 VALUE UBIN HALF UNAL, 2 POSTFIX CHAR (1) INIT ('/'); DCL VALUE_SCAN_STRING REDEF VALUE_SCAN CHAR (4); DCL ARGNO UBIN; DCL NPARAMS UBIN STATIC; DCL RANDOM_SEED UBIN STATIC; DCL RANDOM_M UBIN STATIC INIT (BITBIN('1000000000'O)); DCL RANDOM_A UBIN STATIC INIT (171363); DCL GO_WORD UBIN STATIC; DCL SAY_WORD UBIN STATIC; DCL SUB_STRING CHAR (12) STATIC; DCL SUB_VALUE UBIN STATIC; DCL SUB_LEN UBIN; DCL ITERATION_IC UBIN; DCL ITERATION_COUNT UBIN; DCL ITERATION_TYPE UBIN; DCL ARG$ (0:3) PTR; DCL 1 ARG_PTRS REDEF ARG$, 2 P0$ PTR, 2 P1$ PTR, 2 P2$ PTR, 2 P3$ PTR; DCL IARG$ (0:3) PTR; DCL 1 IARG_PTRS REDEF IARG$, 2 P0$ PTR, 2 P1$ PTR, 2 P2$ PTR, 2 P3$ PTR; DCL TEMP$ PTR; DCL ARG_CLASS (0:3) UBIN; DCL OP_CODE UBIN; DCL NEXT_OP UBIN; DCL OP_LEN (0:%MAX_OPCODE) UBIN WORD STATIC; DCL EXECUTE_IF_SKIPPING(0:%MAX_OPCODE) BIT(36) STATIC; DCL UBIN_WORD (0:0) UBIN WORD BASED; DCL OBJECT$ PTR STATIC; DCL PLACE$ PTR STATIC; DCL VARIABLE$ PTR STATIC; DCL HERE_VAR$ PTR STATIC; DCL HERE_TARGET$ PTR STATIC; DCL THERE_VAR$ PTR STATIC; DCL THERE_TARGET$ PTR STATIC; DCL ITERATOR$ PTR; DCL PARAM$(0:2) PTR STATIC; DCL 1 PARAMS REDEF PARAM$, 2 P0$ PTR, 2 P1$ PTR, 2 P2$ PTR; DCL PARAM_TARGET$ (0:2) PTR STATIC; DCL 1 PARAM_TARGET REDEF PARAM_TARGET$, 2 P0$ PTR, 2 P1$ PTR, 2 P2$ PTR; DCL STATUS_VAR$ PTR STATIC; %MACRO ARGUMENT (NAME=NIL, STCLASS="BASED"); DCL 1 NAME STCLASS, 2 ADDRESS SBIN WORD, 2 VALUE SBIN WORD, 2 LOC SBIN WORD, 2 BITS (0:35) BIT(1) UNAL; %MEND; %ARGUMENT (NAME=ARG, STCLASS=BASED); %ARGUMENT (NAME=ARG1, STCLASS="BASED(ARG_PTRS.P1$)"); %ARGUMENT (NAME=ARG2, STCLASS="BASED(ARG_PTRS.P2$)"); %ARGUMENT (NAME=ARG3, STCLASS="BASED(ARG_PTRS.P3$)"); %ARGUMENT (NAME=IARG1, STCLASS="BASED(IARG_PTRS.P1$)"); %ARGUMENT (NAME=IARG2, STCLASS="BASED(IARG_PTRS.P2$)"); %ARGUMENT (NAME=IARG3, STCLASS="BASED(IARG_PTRS.P3$)"); %ARGUMENT (NAME=HERE, STCLASS="BASED(HERE_VAR$)"); %ARGUMENT (NAME=THERE, STCLASS="BASED(THERE_VAR$)"); %ARGUMENT (NAME=PARAM1, STCLASS="BASED(PARAMS.P1$)"); %ARGUMENT (NAME=PARAM2, STCLASS="BASED(PARAMS.P2$)"); %ARGUMENT (NAME=STATUS, STCLASS="BASED(STATUS_VAR$)"); %ARGUMENT (NAME=ITERATOR, STCLASS="BASED(ITERATOR$)"); %ARGUMENT (NAME=TEMP, STCLASS="BASED(TEMP$)"); %ARGUMENT (NAME=HOLD_PARAM, STCLASS=STATIC); DCL 1 CONSTS (0:3), 2 ADDRESS SBIN, 2 VALUE SBIN, 2 LOC SBIN, 2 BITS BIT (36); DCL ARGS (0:3) SBIN; DCL I SBIN; DCL J SBIN; DCL K SBIN; DCL L SBIN; DCL SAVED_VALUE UBIN STATIC; DCL IF_LEVEL UBIN STATIC; DCL CONNECTIVE UBIN STATIC; DCL TRUTH LOGICAL STATIC; DCL REAL_TRUTH LOGICAL STATIC; DCL NEGATE LOGICAL STATIC; DCL CONTINUE_WITH_THIS_RECORD LOGICAL; DCL FLAG LOGICAL STATIC; DCL TRAP_RETURN BIT(72) DALIGNED STATIC SYMDEF; DCL TRAP_OCCURRED LOGICAL STATIC INIT (%NO#); DCL TERMINAL_IO_ERROR LOGICAL STATIC INIT (%NO#); DCL ACODE_TRAPPED ENTRY ASYNC; DCL MAXIMUM_ETMF UBIN CONSTANT SYMDEF INIT (6); DCL MAXIMUM_USERS UBIN CONSTANT SYMDEF INIT (80); DCL DEMO_GAMES_PERMITTED BIT (1) CONSTANT SYMDEF INIT (%YES#); DCL M$SI DCB; DCL M$LO DCB; DCL M$LM DCB; DCL F$SAVE DCB; DCL F$LOG DCB; %EJECT; HANDLE_MONITOR_ERROR: PROC; YUKK = B$TCB.ALT$ -> B$EXCFR.ERR; REPORT_ERROR.V.DCB# = B$TCB.ALT$ -> B$ALT.DCB#; CALL M$ERRMSG (REPORT_ERROR); CALL M$ERR; END HANDLE_MONITOR_ERROR; %EJECT; GENERATE_NAME: PROC; IF NPARAMS = 1 THEN DO; SAVEFILE_NAME.NAME# = 'SAVED_GAME'; SAVEFILE_NAME.L# = LENGTHC('SAVED_GAME'); END; ELSE DO; CALL CONCAT (SAVEFILE_NAME.NAME#, 'SAVED_GAME_', PARAMETER.TEXT(2)); SAVEFILE_NAME.L# = PARAMETER.LEN(2) + LENGTHC('SAVED_GAME_'); END; RETURN; END GENERATE_NAME; %EJECT; SETUP: PROC; /* SETUP is used to set up the addressing for A-code operands. The variable ARGNO is set up by the calling routine to indicate which operand (1 thru 3) is to be set up; on exit, ARG$(ARGNO) and IARG$(ARGNO) will point to the direct and indirect argument blocks indicated by the value of ARG(ARGNO). ARGNO is passed as a global rather than as a parameter to avoid having to go through the PL6 parameter-setup routines which are a trifle slow, since this is a critical path in the A-code interpreter. */ DCL ARGUMENT SBIN; DCL CLASS UBIN; DCL INDX UBIN; DCL I_ARGUMENT UBIN; DCL I_CLASS UBIN; DCL I_INDX UBIN; ARGUMENT = ARGS(ARGNO); CLASS = ARGUMENT / 1000; INDX = MOD (ARGUMENT, 1000); ARG_CLASS(ARGNO) = CLASS; DO CASE (CLASS); CASE (%OBJECT_TYPE); ARG$(ARGNO) = PINCRW(OBJECT$, INDX * SIZEW(ARG)); CASE (%PLACE_TYPE); ARG$(ARGNO) = PINCRW(PLACE$, INDX * SIZEW(ARG)); CASE (%VARIABLE_TYPE); ARG$(ARGNO) = PINCRW(VARIABLE$, INDX * SIZEW(ARG)); CASE (ELSE); ARG$(ARGNO) = ADDR(CONSTS(ARGNO)); CONSTS.VALUE(ARGNO) = ARGUMENT; CONSTS.LOC(ARGNO) = 0; CONSTS.BITS(ARGNO) = '0'B; IF ARGUMENT >= 0 AND ARGUMENT <= 35 THEN ARG$(ARGNO) -> ARG.BITS(ARGUMENT) = %YES#; END; ARG$(ARGNO) -> ARG.ADDRESS = ARGUMENT; IF CLASS = %VARIABLE_TYPE THEN DO; I_ARGUMENT = ARG$(ARGNO) -> ARG.VALUE; I_CLASS = I_ARGUMENT / 1000; I_INDX = MOD (I_ARGUMENT, 1000); DO CASE (I_CLASS); CASE (%OBJECT_TYPE); IF I_INDX < HEADER_RECORD.NUMBER_OF_OBJECTS THEN DO; IARG$(ARGNO) = PINCRW(OBJECT$, I_INDX * SIZEW(ARG)); IARG$(ARGNO) -> ARG.ADDRESS = I_ARGUMENT; END; ELSE IARG$(ARGNO) = ARG$(ARGNO); CASE (%PLACE_TYPE); IF I_INDX < HEADER_RECORD.NUMBER_OF_PLACES THEN DO; IARG$(ARGNO) = PINCRW(PLACE$, I_INDX * SIZEW(ARG)); IARG$(ARGNO) -> ARG.ADDRESS = I_ARGUMENT; END; ELSE IARG$(ARGNO) = ARG$(ARGNO); CASE (%LABEL_TYPE, %VERB_TYPE, %TEXT_TYPE); IARG$(ARGNO) = ADDR(CONSTS(ARGNO)); CONSTS.VALUE(ARGNO) = I_ARGUMENT; CONSTS.ADDRESS(ARGNO) = I_ARGUMENT; CONSTS.LOC(ARGNO) = 0; CONSTS.BITS(ARGNO) = '0'B; CASE (ELSE); IARG$(ARGNO) = ARG$(ARGNO); END; END; ELSE IARG$(ARGNO) = ARG$(ARGNO); RETURN; END SETUP; %EJECT; READIN: PROC; /* READIN is a procedure used to make A_code records available for interpretation. A binary tree of records is maintained in a data segment first acquired by the initialization logic. When READIN is called, it first checks the tree to see if the record being requested is already available; if so, it sets A_CODE$ to point to the beginning of the record, and returns to the caller. If the record is not in the tree, READIN will attempt to read it into the first available portion of the data segment; if the record does not exist in the database file, a dummy record consisting of an "end of record" code is generated. If the record just read (or created) was an "initialization" record, READIN returns to the caller. If the record was of any other type (and thus eligible for saving), READIN will try to link it onto the binary tree (its proper insertion point is already known since we tried to find it in the tree earlier). For a record to be entered in the tree, there must be enough space left in the data segment, after the end of the record, for one more record of the largest possible length (the maximum length was tracked by the A_code compiler and passed in the header record in the database). If there is not enough space left in the data segment, READIN will try to enlarge the segment by 1 page (4096 words). If the segment is successfully enlarged, or if there was already enough space at the end of the current segment, READIN then goes ahead and links the record onto the tree and sets the "next free location" pointer to the beginning of the first word after the end of the record just linked (this justifies the beginning of each record to a word boundary, which permits the use of an ALIGNED structure for the definition of the record and thus speeds up access to the record contents). If the segment was not successfully enlarged, READIN sets a flag indicating that the segment is full (so that the attempt to enlarge the segment will not be repeated uselessly) and leaves the "next free location" pointer unchanged; any further requests for records not already in the tree will cause the records to be read in on top of the record that was just read in - i.e., the space will be shared. In any case, READIN now returns to the caller. */ DCL INDX UBIN; DCL ARS UBIN; DCL BLINK$ PTR; DCL BLINK_CODE UBIN; BLINK$ = ADDR(NIL); IF INST_AREA_LENGTH > 0 THEN DO; A_CODE$ = INST_AREA.PTR$; DO WHILE (A_CODE$ ~= ADDR(NIL)); IF A_CODE.PREFIX.RECNO = RECORD THEN RETURN; BLINK$ = A_CODE$; IF A_CODE.PREFIX.RECNO > RECORD THEN DO; BLINK_CODE = 0; A_CODE$ = A_CODE.PREFIX.LLINK$; END; ELSE DO; BLINK_CODE = 1; A_CODE$ = A_CODE.PREFIX.RLINK$; END; END; END; DATABASE_KEY.RECORD = RECORD; READ_DATABASE.BUF_.BUF$ = PINCRC(NEXT_INST$, SIZEC(A_CODE.PREFIX)); READ_DATABASE.BUF_.BOUND = INST_AREA_REMAINING - SIZEC(A_CODE.PREFIX) - 1; A_CODE$ = NEXT_INST$; A_CODE.PREFIX.RECNO = RECORD; A_CODE.PREFIX.LLINK$ = ADDR(NIL); A_CODE.PREFIX.RLINK$ = ADDR(NIL); CALL M$READ (READ_DATABASE) ALTRET (NOT_THERE); ARS = F$DATABASE$ -> F$DCB.ARS#; DO NEVER; NOT_THERE: IF B$TCB.ALT$ -> B$EXCFR.ERR.CODE ~= %E$NOKEY THEN CALL HANDLE_MONITOR_ERROR; ARS = 2; A_CODE.OPS(0) = %END_OF_RECORD; END; IF (RECORD / 1000000) ~= %INITIAL_TYPE AND NOT CACHE_FULL THEN DO; IF INST_AREA_REMAINING < 2 * (SIZEC(A_CODE.PREFIX) + 3 + HEADER_RECORD.MAX_BUF_ENTRIES * 2) THEN DO; CALL M$GDS (GET_INST) ALTRET (NO_MORE); INST_AREA_REMAINING = INST_AREA_REMAINING + GET_INST.V.SEGSIZE# * 4; DO NEVER; NO_MORE: CACHE_FULL = %YES#; END; END; IF NOT CACHE_FULL THEN DO; IF BLINK$ ~= ADDR(NIL) THEN DO; DO CASE (BLINK_CODE); CASE (0); BLINK$ -> A_CODE.PREFIX.LLINK$ = A_CODE$; CASE (1); BLINK$ -> A_CODE.PREFIX.RLINK$ = A_CODE$; END; END; ARS = ((ARS + 3) / 4) * 4 + SIZEC(A_CODE.PREFIX); INST_AREA_LENGTH = INST_AREA_LENGTH + ARS; INST_AREA_REMAINING = INST_AREA_REMAINING - ARS; NEXT_INST$ = PINCRC(NEXT_INST$, ARS); END; END; RETURN; END READIN; %EJECT; SPEAK: PROC (THING); %ARGUMENT (NAME=THING, STCLASS=""); DCL PHRASE UBIN; DCL LIMIT UBIN; DCL SUB UBIN; DCL SLASH UBIN; DCL ENDSUB UBIN; DCL VFC_EXISTS LOGICAL; PHRASE = THING.ADDRESS * 1000; LIMIT = 10; VFC_EXISTS = %NO#; DO CASE (THING.ADDRESS / 1000); CASE (%OBJECT_TYPE); IF THING.LOC ~= %CARRYING THEN PHRASE = PHRASE + 10 * (THING.VALUE + 1); CASE (%PLACE_TYPE); IF NOT STATUS.BITS(%FAST_BIT) AND (NOT (STATUS.BITS(%BRIEF_BIT) AND THING.BITS(%BEEN_HERE_BIT)) OR STATUS.BITS(%FULL_DISP_BIT)) THEN DO; PHRASE = PHRASE + 10; LIMIT = 490; END; CASE (%TEXT_TYPE); LIMIT = 500; DO CASE (MOD(THING.ADDRESS, 1000)); CASE (0); RETURN; CASE (1); MESSAGE = ' '; CALL M$WRITE (WRITE_LO); RETURN; CASE (2); MESSAGE = 'Ok.'; CALL M$WRITE (WRITE_LO); RETURN; CASE (ELSE); END; CASE (ELSE); CALL GLITCH ('Invalid argument to SPEAK! Record =/', RECORD, 'IC =/', IC, 'Item =/', THING.ADDRESS); RETURN; END; READ_DATABASE.BUF_ = VECTOR(MESSAGE); DO WHILE (LIMIT > 0); DATABASE_KEY.RECORD = PHRASE; PHRASE = PHRASE + 1; LIMIT = LIMIT - 1; MESSAGE = ' '; CALL M$READ (READ_DATABASE) ALTRET (DONE); IF SUB_LEN > 0 THEN DO; DO FOREVER; CALL INDEX1 (SUB, '#', MESSAGE) ALTRET (PHASE_2); CALL XLATE (TEMP_MESSAGE, XLATE_TO_LC, SUB_STRING); IF SUB = 0 THEN CALL XLATE (SUBSTR(TEMP_MESSAGE, 0, 1), XLATE_TO_UC, SUBSTR(SUB_STRING, 0, 1)); SUB_STRING = TEMP_MESSAGE; CALL CONCAT (TEMP_MESSAGE, SUBSTR(MESSAGE, 0, SUB), SUBSTR(SUB_STRING, 0, SUB_LEN), SUBSTR(MESSAGE, SUB + 1)); MESSAGE = TEMP_MESSAGE; END; END; PHASE_2: DO FOREVER; CALL INDEX1 (SUB, '[', MESSAGE) ALTRET (SUB_DONE); CALL INDEX1 (SLASH, '/', MESSAGE, SUB) ALTRET (BAD_SUB); CALL INDEX1 (ENDSUB, ']', MESSAGE, SLASH) ALTRET (BAD_SUB); IF (SUB_VALUE = 1 AND SLASH = SUB + 1) OR (SUB_VALUE ~= 1 AND ENDSUB = SLASH + 1) THEN CALL CONCAT (TEMP_MESSAGE, SUBSTR(MESSAGE, 0, SUB), SUBSTR(MESSAGE, ENDSUB + 1)); ELSE IF SUB_VALUE = 1 THEN CALL CONCAT (TEMP_MESSAGE, SUBSTR(MESSAGE, 0, SUB), SUBSTR(MESSAGE, SUB + 1, SLASH - SUB - 1), SUBSTR(MESSAGE, ENDSUB + 1)); ELSE CALL CONCAT (TEMP_MESSAGE, SUBSTR(MESSAGE, 0, SUB), SUBSTR(MESSAGE, SLASH + 1, ENDSUB - SLASH - 1), SUBSTR(MESSAGE, ENDSUB + 1)); MESSAGE = TEMP_MESSAGE; END; DO NEVER; BAD_SUB: CALL GLITCH ('Incorrect substitution request: key =/', PHRASE); END; SUB_DONE: IF SUBSTR(MESSAGE, 0, 1) = '!' THEN DO; VFC_EXISTS = %YES#; WRITE_LO.BUF_ = VECTOR(SUBSTR(MESSAGE, 1)); WRITE_LO.V.DVBYTE.VFC# = %YES#; END; CALL M$WRITE (WRITE_LO); IF VFC_EXISTS THEN DO; VFC_EXISTS = %NO#; WRITE_LO.BUF_ = VECTOR(MESSAGE); WRITE_LO.V.DVBYTE.VFC# = %NO#; END; END; DONE: RETURN; END SPEAK; %EJECT; GLITCH: PROC (GRIPE, VALUE1, TITLE2, VALUE2, TITLE3, VALUE3) ALTRET; DCL GRIPE CHAR (120); DCL TITLE2 CHAR (120); DCL TITLE3 CHAR (120); DCL VALUE1 UBIN; DCL VALUE2 UBIN; DCL VALUE3 UBIN; DCL NEXT_CHAR UBIN; STUFF_STRING: PROC (STRING); DCL STRING CHAR (120); DCL STOP UBIN; IF ADDR(STRING) = ADDR(NIL) THEN RETURN; CALL INDEX1 (STOP, '/', STRING); CALL INSERT (MESSAGE, NEXT_CHAR, STOP, STRING); NEXT_CHAR = NEXT_CHAR + STOP + 1; RETURN; END STUFF_STRING; STUFF_NUMBER: PROC (NUMBER); DCL NUMBER UBIN; DCL CHAR_NUMBER CHAR (7); IF ADDR(NUMBER) = ADDR(NIL) THEN RETURN; CALL BINCHAR (CHAR_NUMBER, NUMBER); CALL INSERT (MESSAGE, NEXT_CHAR, , CHAR_NUMBER); NEXT_CHAR = NEXT_CHAR + LENGTHC(CHAR_NUMBER) + 1; RETURN; END STUFF_NUMBER; MESSAGE = 'Glitch!'; NEXT_CHAR = 8; CALL STUFF_STRING (GRIPE); CALL STUFF_NUMBER (VALUE1); CALL STUFF_STRING (TITLE2); CALL STUFF_NUMBER (VALUE2); CALL STUFF_STRING (TITLE3); CALL STUFF_NUMBER (VALUE3); CALL M$WRITE (WRITE_LO); ALTRETURN; END GLITCH; %EJECT; IF_TEST: PROC; /* IF_TEST is called by the various A_code routines that perform comparisons and logical tests. The A-code routines are responsible for setting the variable TRUTH equal to a true or false value to indicate the outcome of the test that they have performed. IF_TEST will perform any ANDing, ORing, or EORing of a previous truth result that may have been called for by a previous connective, check to see if the next A-code is a connective (AND, OR, or EOR), and will (if necessary) set the IF_LEVEL. */ IF NEGATE THEN TRUTH = ~ TRUTH; NEGATE = %NO#; DO CASE (CONNECTIVE); CASE (%FIRST_TRUTH); REAL_TRUTH = TRUTH; CASE (%AND_TRUTH); REAL_TRUTH = REAL_TRUTH & TRUTH; CASE (%OR_TRUTH); REAL_TRUTH = REAL_TRUTH | TRUTH; CASE (%EOR_TRUTH); REAL_TRUTH = (REAL_TRUTH & ~ TRUTH) | (TRUTH & ~ REAL_TRUTH); END; CONNECTIVE = %FIRST_TRUTH; NEXT_OP = A_CODE.OPS(NEXT_IC); IF NEXT_OP ~= %AND_OP AND NEXT_OP ~= %OR_OP AND NEXT_OP ~= %EOR_OP THEN DO; IF IF_LEVEL > 0 OR NOT REAL_TRUTH THEN IF_LEVEL = IF_LEVEL + 1; END; RETURN; END IF_TEST; %EJECT; GO_TO: PROC (WHERE); %ARGUMENT (NAME=WHERE, STCLASS=" "); THERE.VALUE = HERE.VALUE; HERE.VALUE = WHERE.ADDRESS; STATUS.BITS(%MOVED_BIT) = %YES#; RETURN; END GO_TO; %EJECT; GET_RANDOM: PROC (RNO); DCL RNO UBIN; RANDOM_SEED = MOD(BITBIN(BINBIT(RANDOM_SEED * RANDOM_A, 36) & '377777777777'O), RANDOM_M); RNO = RANDOM_SEED; RETURN; END GET_RANDOM; %EJECT; LOOKUP_WORD: PROC (STRING, LEN, SYMVAL); DCL STRING CHAR (12); DCL LEN UBIN; DCL SYMVAL UBIN; DCL LOC UBIN; DCL 1 SCAN, 2 INFIX CHAR (1), 2 NAME CHAR (13); DCL SCAN_STRING REDEF SCAN CHAR (14); SCAN.INFIX = '/'; SCAN.NAME = STRING; CALL INSERT (SCAN.NAME, LEN, , '@'); CALL INDEX (LOC, SUBSTR(SCAN_STRING, 0, LEN + 2), VOCAB_TEXT) ALTRET (FIRST_PASS_FAILED); DO NEVER; FIRST_PASS_FAILED: CALL INSERT (SCAN.NAME, LEN, , '$'); CALL INDEX (LOC, SUBSTR(SCAN_STRING, 0, LEN + 2), VOCAB_TEXT) ALTRET (SECOND_PASS_FAILED); END; ENTRY$ = PINCRC(VOCAB_AREA.PTR$, LOC - SIZEC(VOCAB_ENTRY.PREFIX) - SIZEC(VOCAB_ENTRY.VALUE)); SYMVAL = VOCAB_ENTRY.VALUE; RETURN; SECOND_PASS_FAILED: SYMVAL = 9999; RETURN; END LOOKUP_WORD; %EJECT; INPUT: PROC; DCL SYMVAL UBIN; DCL START UBIN; DCL FIRST UBIN; DCL LAST UBIN; DCL LEN UBIN; DCL SCRATCH UBIN; DCL INDX UBIN; NPARAMS = 0; IF STATUS.BITS (%PLS_CLARIFY_BIT) THEN DO; HOLD_PARAM = PARAM1; PARAM_TARGET$(0) = PARAM_TARGET$(1); PARAMETER(0) = PARAMETER(1); END; DO I = 1 TO 2; PARAMETER.TEXT(I) = '{glitch}'; PARAMETER.LEN(I) = 8; PARAM$(I) -> ARG.VALUE = 9999; PARAM$(I) -> ARG.BITS = '0'B; END; COMMAND = ' '; CALL M$READ (READ_SI) ALTRET (DIE); DO NEVER; DIE: IF B$TCB.ALT$ -> B$EXCFR.ERR.CODE ~= %E$LD THEN IF TERMINAL_IO_ERROR THEN CALL HANDLE_MONITOR_ERROR; ELSE DO; TERMINAL_IO_ERROR = %YES#; CALL M$RETRY; END; END; TERMINAL_IO_ERROR = %NO#; START = 0; DO WHILE (NPARAMS < 2); CALL SEARCH (FIRST, SCRATCH, STOP_ON_NONBLANK, COMMAND, START) ALTRET (EOL_HIT); CALL INDEX1 (LAST, ' ', COMMAND, FIRST) ALTRET (LONG); DO NEVER; LONG: LAST = LENGTHC(COMMAND) + 1; END; LEN = LAST - FIRST; IF LEN > 12 THEN LEN = 12; NPARAMS = NPARAMS + 1; PARAMETER.LEN(NPARAMS) = LEN; CALL XLATE (PARAMETER.TEXT(NPARAMS), XLATE_TO_UC, SUBSTR(COMMAND, FIRST, LEN)); CALL LOOKUP_WORD (PARAMETER.TEXT(NPARAMS), LEN, SYMVAL); PARAM$(NPARAMS) -> ARG.VALUE = SYMVAL; INDX = MOD(SYMVAL, 1000); DO CASE (SYMVAL / 1000); CASE (%OBJECT_TYPE); PARAM_TARGET$(NPARAMS) = PINCRW(OBJECT$, INDX * SIZEW(ARG)); PARAM_TARGET$(NPARAMS) -> ARG.BITS(%OBJECT_BIT) = %YES#; CASE (%PLACE_TYPE); PARAM_TARGET$(NPARAMS) = PINCRW(PLACE$, INDX * SIZEW(ARG)); PARAM_TARGET$(NPARAMS) -> ARG.BITS(%PLACE_BIT) = %YES#; CASE (%VERB_TYPE); PARAM_TARGET$(NPARAMS) = PARAM$(NPARAMS); PARAM_TARGET$(NPARAMS) -> ARG.BITS(%VERB_BIT) = %YES#; CASE (%NULLWORD_TYPE); NPARAMS = NPARAMS - 1; CASE (ELSE); PARAM_TARGET$(NPARAMS) = PARAM$(NPARAMS); END; START = LAST + 1; END; EOL_HIT: IF NPARAMS = 1 AND STATUS.BITS(%PLS_CLARIFY_BIT) THEN DO; PARAM2 = HOLD_PARAM; IF (PARAM2.VALUE / 1000) = %VERB_TYPE THEN PARAM_TARGET$(2) = PARAM$(2); ELSE PARAM_TARGET$(2) = PARAM_TARGET$(0); PARAMETER(2) = PARAMETER(0); NPARAMS = 2; END; STATUS.BITS(%PLS_CLARIFY_BIT) = %NO#; IF NPARAMS = 2 AND PARAM_TARGET$(2) -> ARG.BITS(%VERB_BIT) AND (PARAM_TARGET$(1) -> ARG.BITS(%OBJECT_BIT) OR PARAM_TARGET$(1) -> ARG.BITS(%PLACE_BIT)) THEN DO; I = PARAM1.VALUE; PARAM1.VALUE = PARAM2.VALUE; PARAM2.VALUE = I; PARAM_TARGET$(0) = PARAM_TARGET$(1); PARAM_TARGET$(1) = PARAM_TARGET$(2); PARAM_TARGET$(2) = PARAM_TARGET$(0); PARAMETER(0) = PARAMETER(1); PARAMETER(1) = PARAMETER(2); PARAMETER(2) = PARAMETER(0); END; STATUS.VALUE = NPARAMS; RETURN; END INPUT; %EJECT; INITIALIZE_ACODE: ENTRY; F$DATABASE$ = DCBADDR(DCBNUM(F$DATABASE)); F$SAVE$ = DCBADDR(DCBNUM(F$SAVE)); DATABASE_ACCOUNT.ACCT# = DCBADDR(DCBNUM(M$LM)) -> F$DCB.ACCT#; CALL M$SCON (FPT_SCON); CALL M$OPEN (OPEN_SI) ALTRET (M$BLETCH); CALL M$OPEN (OPEN_LO) ALTRET (M$BLETCH); CALL M$OPEN (OPEN_DATABASE) ALTRET (M$BLETCH); DATABASE_KEY.RECORD = %HEADER_TYPE * 1000 * 1000; READ_DATABASE.BUF_ = VECTOR(HEADER_RECORD); CALL M$READ (READ_DATABASE) ALTRET (M$BLETCH); IF HEADER_RECORD.VOCAB_SIZE > 9999 OR HEADER_RECORD.MAX_BUF_ENTRIES > 9999 OR HEADER_RECORD.NUMBER_OF_OBJECTS > 999 OR HEADER_RECORD.NUMBER_OF_PLACES > 999 OR HEADER_RECORD.NUMBER_OF_VARIABLES > 999 THEN DO; CALL GLITCH ('Database file is incredibly malformed!!/'); CALL M$ERR; END; GET_VOCAB.V.SEGSIZE# = ((HEADER_RECORD.VOCAB_SIZE + 11) + 3) / 4; CALL M$GDS (GET_VOCAB) ALTRET (M$BLETCH); READ_DATABASE.BUF_.BUF$ = VOCAB_AREA.PTR$; READ_DATABASE.BUF_.BOUND = HEADER_RECORD.VOCAB_SIZE - 1; DATABASE_KEY.RECORD = (%HEADER_TYPE * 1000 + 1) * 1000; CALL M$READ (READ_DATABASE) ALTRET (M$BLETCH); J = SIZEW(ARG) * (HEADER_RECORD.NUMBER_OF_OBJECTS + HEADER_RECORD.NUMBER_OF_PLACES + HEADER_RECORD.NUMBER_OF_VARIABLES); GET_DATA.V.SEGSIZE# = J; CALL M$GDS (GET_DATA) ALTRET (M$BLETCH); OBJECT$ = DATA_AREA.PTR$; PLACE$ = PINCRW(OBJECT$, SIZEW(ARG) * HEADER_RECORD.NUMBER_OF_OBJECTS); VARIABLE$ = PINCRW(PLACE$, SIZEW(ARG) * HEADER_RECORD.NUMBER_OF_PLACES); HERE_VAR$ = PINCRW(VARIABLE$, SIZEW(ARG) * %HERE_INDEX); THERE_VAR$ = PINCRW(VARIABLE$, SIZEW(ARG) * %THERE_INDEX); PARAMS.P1$ = PINCRW(VARIABLE$, SIZEW(ARG) * %PARAM1_INDEX); PARAMS.P2$ = PINCRW(VARIABLE$, SIZEW(ARG) * %PARAM2_INDEX); STATUS_VAR$ = PINCRW(VARIABLE$, SIZEW(ARG) * %STATUS_INDEX); DO I = 0 TO J - 1; DATA_AREA.PTR$ -> UBIN_WORD(I) = 0; END; CALL M$GDS (GET_INST) ALTRET (M$BLETCH); INST_AREA_REMAINING = GET_INST.V.SEGSIZE# * 4; NEXT_INST$ = INST_AREA.PTR$; DO I = 0 TO 127; XLATE_TO_UC(I) = I; END; XLATE_TO_LC = XLATE_TO_UC; DO I = ASCBIN('A') TO ASCBIN('Z'); XLATE_TO_LC(I) = I + %SHIFT; XLATE_TO_UC(I + %SHIFT) = I; END; CALL LOOKUP_WORD ('GO', 2, GO_WORD); CALL LOOKUP_WORD ('SAY', 3, SAY_WORD); DO I = 1 TO %MAX_OPCODE; DO CASE (I); CASE( %ANYOF_OP ); OP_LEN(I) = 0; CASE( %KEYWORD_OP, %HAVE_OP, %NEAR_OP, %ELSE_OP, %FIN_OP, %EOF_OP, %PROCEED_OP, %QUIT_OP, %STOP_OP, %OR_OP, %EOI_OP, %INPUT_OP, %NOT_OP, %AND_OP, %EOR_OP ); OP_LEN (I) = 1; CASE( %AT_OP, %IFAT_OP, %CHANCE_OP, %GET_OP, %DROP_OP, %GOTO_OP, %CALL_OP, %SAY_OP, %IFHAVE_OP, %IFNEAR_OP, %ITOBJECT_OP, %ITPLACE_OP, %IFKEY_OP, %QUERY_OP, %ITLIST_OP, %DEFAULT_OP ); OP_LEN (I) = 2; CASE( %IFEQ_OP, %IFLT_OP, %IFGT_OP, %APPORT_OP, %SET_OP, %ADD_OP, %SUB_OP, %MOVE_OP, %NAME_OP, %VALUE_OP, %RANDOM_OP, %BIT_OP, %BIS_OP, %BIC_OP, %IFLOC_OP, %LOCATE_OP, %LDA_OP, %EVAL_OP, %MULTIPLY_OP, %DIVIDE_OP, %SVARIABLE_OP, %EXECUTIVE_OP, %DEPOSIT_OP ); OP_LEN (I) = 3; CASE( %SMOVE_OP ); OP_LEN (I) = 4; CASE (ELSE); CALL GLITCH('Opcode not in length tables!/', I); END; DO CASE (I); CASE (%IFAT_OP, %CHANCE_OP, %IFHAVE_OP, %IFNEAR_OP, %IFKEY_OP, %QUERY_OP, %IFEQ_OP, %IFLT_OP, %IFGT_OP, %IFLOC_OP, %AND_OP, %OR_OP, %EOR_OP, %FIN_OP, %EOF_OP, %ELSE_OP, %BIT_OP); EXECUTE_IF_SKIPPING(I) = %YES#; CASE (ELSE); EXECUTE_IF_SKIPPING(I) = %NO#; END; END; CALL M$TRAP (FPT_TRAP); CALL M$MONINFO (FPT_MONINFO); L = VLR_SITEINFO.SITE_NAME#.L; IF L > 20 THEN L = 20; CALL CONCAT (LOG_FILE_NAME.NAME#, 'ADVENTURES:', VLR_SITEINFO.SITE_NAME#.C); L = L + LENGTHC('ADVENTURES:'); LOG_FILE_NAME.L# = L; DO FOREVER; CALL INDEX (I, ' ', SUBSTR(LOG_FILE_NAME.NAME#, 0, L)) ALTRET (NO_BLANKS); CALL INSERT (LOG_FILE_NAME.NAME#, I, 1, '_'); END; NO_BLANKS: CALL M$OPEN (OPEN_LOG_FILE) ALTRET (NO_LOG_FILE); CALL M$TIME (GET_DATE_AND_TIME); CALL CONCAT (LOG_FILE_RECORD, B$JIT.ACCN, ' ', B$JIT.UNAME, ' ', DATE_INFO.DAY#); CALL INSERT (LOG_FILE_RECORD, 27, , DATE_INFO.DATE#, ' ', DATE_INFO.TIME#); CALL M$WRITE (WRITE_LOG_FILE) ALTRET (M$BLETCH); CALL M$CLOSE (CLOSE_LOG_FILE) ALTRET (M$BLETCH); NO_LOG_FILE: RANDOM_SEED = MOD(B$JIT.CALCNT, RANDOM_M) / 2 * 2 + 1; RETURN; M$BLETCH: CALL HANDLE_MONITOR_ERROR; %EJECT; CHECK_PRIME: PROC (DAY, RESULT) ALTRET; DCL 1 DAY, 2 ABBREV CHAR (4), 2 FULL CHAR (12), 2 BLOCK1, 3 START CHAR (4), 3 STOP CHAR (4), 2 BLOCK2, 3 START CHAR (4), 3 STOP CHAR (4), 2 BLOCK3, 3 START CHAR (4), 3 STOP CHAR (4); DCL RESULT UBIN; IF DAY_OF_WEEK ~= DAY.ABBREV THEN RETURN; IF (HOUR_OF_DAY >= DAY.BLOCK1.START AND HOUR_OF_DAY <= DAY.BLOCK1.STOP) OR (HOUR_OF_DAY >= DAY.BLOCK2.START AND HOUR_OF_DAY <= DAY.BLOCK2.STOP) OR (HOUR_OF_DAY >= DAY.BLOCK3.START AND HOUR_OF_DAY <= DAY.BLOCK3.STOP) THEN RESULT = 0; ELSE RESULT = 1; ALTRETURN; END CHECK_PRIME; %EJECT; PRINT_HOURS: PROC (DAY); DCL 1 DAY, 2 ABBREV CHAR (4), 2 FULL CHAR (12), 2 BLOCK (0:2), 3 START CHAR (4), 3 STOP CHAR (4); DCL I UBIN; DCL COLUMN UBIN; MESSAGE = ' '; CALL INSERT (MESSAGE, 2, , DAY.FULL); COLUMN = 15; I = 0; DO WHILE (I < 3); IF DAY.BLOCK.START(I) = '0000' AND DAY.BLOCK.STOP(I) = '2400' THEN DO; CALL INSERT (MESSAGE, COLUMN, , 'All day.'); I = 3; END; ELSE DO; IF DAY.BLOCK.START(I) = '0000' THEN DO; CALL INSERT (MESSAGE, COLUMN, , 'Midnite'); COLUMN = COLUMN + 7; END; ELSE DO; CALL INSERT (MESSAGE, COLUMN, , DAY.BLOCK.START(I)); COLUMN = COLUMN + 4; END; CALL INSERT (MESSAGE, COLUMN, , ' to '); COLUMN = COLUMN + 4; IF DAY.BLOCK.STOP(I) = '2400' THEN DO; CALL INSERT (MESSAGE, COLUMN, , 'midnite.'); I = 3; END; ELSE DO; CALL INSERT (MESSAGE, COLUMN, , DAY.BLOCK.STOP(I), ', '); COLUMN = COLUMN + 6; I = I + 1; END; END; END; CALL M$WRITE (WRITE_LO); MESSAGE = ' '; CALL M$WRITE (WRITE_LO); RETURN; END PRINT_HOURS; %EJECT; EXECUTIVE: PROC; DO CASE (IARG1.VALUE); CASE (1); /* SAVE current status */; CALL GENERATE_NAME; OPEN_SAVEFILE.V.FUN# = %CREATE#; OPEN_SAVEFILE.V.ORG# = %CONSEC#; OPEN_SAVEFILE.V.DELETE# = %NO#; OPEN_SAVEFILE.V.EXIST# = %NEWFILE#; OPEN_SAVEFILE.V.INITZ.SCRUB# = %YES#; OPEN_SAVEFILE.V.DISP# = %NAMED#; CALL M$OPEN (OPEN_SAVEFILE) ALTRET (EXECUTIVE_ALTRET); WRITE_SAVEFILE.BUF_ = VECTOR(HEADER_RECORD); CALL M$WRITE (WRITE_SAVEFILE) ALTRET (EXECUTIVE_ALTRET); WRITE_SAVEFILE.BUF_ = DATA_AREA; CALL M$WRITE (WRITE_SAVEFILE) ALTRET (EXECUTIVE_ALTRET); CLOSE_SAVEFILE.V.DISP# = %SAVE#; CALL M$CLOSE (CLOSE_SAVEFILE) ALTRET (EXECUTIVE_ALTRET); ARG2.VALUE = 0; CASE (2); /* RESTORE saved status */ CALL GENERATE_NAME; OPEN_SAVEFILE.V.FUN# = %IN#; OPEN_SAVEFILE.V.DELETE# = %NO#; OPEN_SAVEFILE.V.INITZ.SCRUB# = %YES#; CALL M$OPEN (OPEN_SAVEFILE) ALTRET (EXECUTIVE_ALTRET); READ_SAVEFILE.BUF_ = VECTOR(SAVEFILE); CALL M$READ (READ_SAVEFILE) ALTRET (EXECUTIVE_ALTRET); I = 2; IF HEADER_RECORD.NUMBER_OF_OBJECTS = SAVEFILE.NUMBER_OF_OBJECTS AND HEADER_RECORD.NUMBER_OF_PLACES = SAVEFILE.NUMBER_OF_PLACES AND HEADER_RECORD.NUMBER_OF_VARIABLES = SAVEFILE.NUMBER_OF_VARIABLES THEN DO; I = 0; READ_SAVEFILE.BUF_ = DATA_AREA; CALL M$READ (READ_SAVEFILE) ALTRET (EXECUTIVE_ALTRET); END; CLOSE_SAVEFILE.V.DISP# = %SAVE#; CALL M$CLOSE (CLOSE_SAVEFILE) ALTRET (EXECUTIVE_ALTRET); ARG2.VALUE = I; CASE (3); /* Delete save file image */ CALL GENERATE_NAME; OPEN_SAVEFILE.V.FUN# = %IN#; OPEN_SAVEFILE.V.DELETE# = %YES#; CALL M$OPEN (OPEN_SAVEFILE) ALTRET (DELETE_FAILED); DELETE_FAILED: ARG2.VALUE = 0; CASE (4); /* Clear the cache - not used in CP-6 */ CASE (5); /* check if cave can be entered */ CALL M$DISPLAY (FPT_DISPLAY); CALL M$TIME (GET_DATE_AND_TIME); CALL XLATE (DAY_OF_WEEK, XLATE_TO_UC, DATE_INFO.DAY#); CALL CONCAT(HOUR_OF_DAY, SUBSTR(DATE_INFO.TIME#, 0, 2), SUBSTR(DATE_INFO.TIME#, 3, 2)); CALL CHECK_PRIME (MONDAY, I) ALTRET (GOT_PRIME_FLAG); CALL CHECK_PRIME (TUESDAY, I) ALTRET (GOT_PRIME_FLAG); CALL CHECK_PRIME (WEDNESDAY, I) ALTRET (GOT_PRIME_FLAG); CALL CHECK_PRIME (THURSDAY, I) ALTRET (GOT_PRIME_FLAG); CALL CHECK_PRIME (FRIDAY, I) ALTRET (GOT_PRIME_FLAG); CALL CHECK_PRIME (SATURDAY, I) ALTRET (GOT_PRIME_FLAG); CALL CHECK_PRIME (SUNDAY, I) ALTRET (GOT_PRIME_FLAG); CALL GLITCH ('I don''t know what day it is!/'); I = 0; GOT_PRIME_FLAG: IF I = 0 THEN IF VLR_DISPLAY.ETMF > MAXIMUM_ETMF THEN I = 2; ELSE IF VLR_DISPLAY.USERS > MAXIMUM_USERS THEN I = 3; ARG2.VALUE = I; CASE (6); /* print hours that the cave is open */ CALL PRINT_HOURS (MONDAY); CALL PRINT_HOURS (TUESDAY); CALL PRINT_HOURS (WEDNESDAY); CALL PRINT_HOURS (THURSDAY); CALL PRINT_HOURS (FRIDAY); CALL PRINT_HOURS (SATURDAY); CALL PRINT_HOURS (SUNDAY); CASE (7); /* save a value across RESTORE */ SAVED_VALUE = ARG2.VALUE; CASE (8); /* restore value after RESTORE */ ARG2.VALUE = SAVED_VALUE; CASE (9); /* exit if demo games not permitted */ IF NOT DEMO_GAMES_PERMITTED THEN CALL M$EXIT; CASE (ELSE); CALL GLITCH ('Unimplemented EXECUTIVE option! Record =/', RECORD, 'IC =/', IC, 'Option =/', IARG1.VALUE); ARG2.VALUE = 0; END; RETURN; EXECUTIVE_ALTRET: ARG2.VALUE = 1; IF F$SAVE$ -> F$DCB.FCD# THEN DO; CLOSE_SAVEFILE.V.DISP# = %RELEASE#; CALL M$CLOSE (CLOSE_SAVEFILE) ALTRET (CLOSE_FAILED); CLOSE_FAILED: END; END EXECUTIVE; %EJECT; PROCESS: ENTRY (RECNO) ALTRET; RECORD = (RECNO * 1000) + 500; REMEMBER WE_HAVE_TRAPPED IN TRAP_RETURN; DO FOREVER; CALL READIN; IF A_CODE.OPS(0) = %END_OF_RECORD THEN RETURN; IC = 0; IF_LEVEL = 0; CONNECTIVE = %FIRST_TRUTH; REAL_TRUTH = %YES#; NEGATE = %NO#; CONTINUE_WITH_THIS_RECORD = %YES#; DO WHILE (A_CODE.OPS(IC) ~= %END_OF_RECORD AND CONTINUE_WITH_THIS_RECORD); OP_CODE = A_CODE.OPS(IC); NEXT_IC = IC + OP_LEN(OP_CODE); IF IF_LEVEL = 0 OR EXECUTE_IF_SKIPPING(OP_CODE) THEN DO; DO ARGNO = 1 TO OP_LEN(OP_CODE) - 1; ARGS(ARGNO) = A_CODE.OPS(IC + ARGNO); CALL SETUP; END; DO CASE (OP_CODE); CASE (%ADD_OP); ARG1.VALUE = ARG1.VALUE + ARG2.VALUE; CASE (%AND_OP); CONNECTIVE = %AND_TRUTH; CASE (%ANYOF_OP); FLAG = %NO#; DO WHILE (A_CODE.OPS(NEXT_IC) = %ANYOF_OP); NEXT_IC = NEXT_IC + 1; DO WHILE (A_CODE.OPS(NEXT_IC) > %MAX_OPCODE); OP_CODE = A_CODE.OPS(NEXT_IC); NEXT_IC = NEXT_IC + 1; IF NPARAMS > 0 AND (OP_CODE = PARAM1.VALUE OR (NPARAMS = 2 AND OP_CODE = PARAM2.VALUE)) THEN FLAG = %YES#; END; END; CONTINUE_WITH_THIS_RECORD = FLAG; CASE (%APPORT_OP); IARG1.LOC = IARG2.ADDRESS; STATUS.BITS(%JUGGLED_BIT) = %YES#; CASE (%AT_OP); CONTINUE_WITH_THIS_RECORD = (ARG1.ADDRESS = HERE.VALUE); CASE (%BIC_OP); IARG1.BITS = IARG1.BITS & ~ IARG2.BITS; CASE (%BIS_OP); IARG1.BITS = IARG1.BITS | IARG2.BITS; CASE (%BIT_OP); TRUTH = (IARG1.BITS & IARG2.BITS) ~= '0'B; CALL IF_TEST; CASE (%CALL_OP); CALL PROCESS (IARG1.ADDRESS) ALTRET (FLUSH); REMEMBER WE_HAVE_TRAPPED IN TRAP_RETURN; CASE (%CHANCE_OP); CALL GET_RANDOM (I); TRUTH = (MOD(I / 100, 100) < IARG1.VALUE); CALL IF_TEST; CASE (%DEFAULT_OP); IF STATUS.VALUE = 1 THEN DO; L = -1; DO I = 0 TO HEADER_RECORD.NUMBER_OF_OBJECTS - 1; TEMP$ = PINCRW(OBJECT$, SIZEW(ARG) * I); IF (TEMP.BITS & ARG1.BITS) ~= '0'B AND (TEMP.LOC = HERE.VALUE OR (TEMP.LOC = HERE.VALUE - 1 AND TEMP.BITS(%SCHIZOID_BIT))) THEN IF L = -1 THEN L = I; ELSE L = -2; END; IF L >= 0 THEN DO; STATUS.VALUE = 2; NPARAMS = 2; PARAMETER.LEN(2) = 0; PARAM2.VALUE = L + (%OBJECT_TYPE * 1000); PARAM_TARGET$(2) = PINCRW(OBJECT$, SIZEW(ARG) * L); PARAM_TARGET$(2) -> ARG.BITS(%OBJECT_BIT) = %YES#; END; END; CASE (%DEPOSIT_OP); IARG1.VALUE = ARG2.VALUE; CASE (%DIVIDE_OP); IF ARG2.VALUE ~= 0 THEN ARG1.VALUE = ARG1.VALUE / ARG2.VALUE; CASE (%DROP_OP); IARG1.LOC = HERE.VALUE; STATUS.BITS(%JUGGLED_BIT) = %YES#; CASE (%ELSE_OP); IF IF_LEVEL <= 1 THEN IF_LEVEL = 1 - IF_LEVEL; CASE (%EOF_OP); IF_LEVEL = 0; CASE (%EOI_OP); FLAG = %YES#; DO WHILE (FLAG); ITERATION_COUNT = ITERATION_COUNT - 1; ITERATOR.VALUE = ITERATOR.VALUE + 1; FLAG = %NO#; IF ITERATION_COUNT > 0 THEN DO; DO CASE (ITERATION_TYPE); CASE (%ITERATE_PLACES, %ITERATE_OBJECTS); NEXT_IC = ITERATION_IC; CASE (%ITERATE_OBJECTS_HERE); TEMP$ = PINCRW(OBJECT$, SIZEW(ARG) * MOD (ITERATOR.VALUE, 1000)); I = TEMP.LOC; IF I = %CARRYING OR I = HERE.VALUE OR (I = HERE.VALUE - 1 AND TEMP.BITS(%SCHIZOID_BIT)) THEN NEXT_IC = ITERATION_IC; ELSE FLAG = %YES#; END; END; END; CASE (%EOR_OP); CONNECTIVE = %EOR_TRUTH; CASE (%EVAL_OP); ARG1.VALUE = IARG2.VALUE; CASE (%EXECUTIVE_OP); CALL EXECUTIVE; CASE (%FIN_OP); IF IF_LEVEL > 0 THEN IF_LEVEL = IF_LEVEL - 1; CASE (%GET_OP); IARG1.LOC = %CARRYING; STATUS.BITS(%JUGGLED_BIT) = %YES#; CASE (%GOTO_OP); CALL GO_TO (IARG1); CASE (%HAVE_OP); DO WHILE (CONTINUE_WITH_THIS_RECORD AND A_CODE.OPS(NEXT_IC) > %MAX_OPCODE); OP_CODE = A_CODE.OPS(NEXT_IC); NEXT_IC = NEXT_IC + 1; IF (OP_CODE / 1000) = %VARIABLE_TYPE THEN OP_CODE = PINCRW(VARIABLE$, SIZEW(ARG) * MOD(OP_CODE, 1000)) -> ARG.VALUE; IF (OP_CODE / 1000) ~= %OBJECT_TYPE THEN CALL GLITCH ('Illegal "HAVE" - record =/', RECORD, 'IC =/', IC, 'operand =/', OP_CODE) ALTRET (TERMINATE_HAVE); ELSE DO; IARG_PTRS.P1$ = PINCRW(OBJECT$, MOD(OP_CODE, 1000) * SIZEW(ARG)); IF IARG1.LOC ~= %CARRYING THEN TERMINATE_HAVE: CONTINUE_WITH_THIS_RECORD = %NO#; END; END; CASE (%IFAT_OP); TRUTH = (IARG1.ADDRESS = HERE.VALUE); CALL IF_TEST; CASE (%IFEQ_OP); TRUTH = (ARG1.VALUE = ARG2.VALUE); CALL IF_TEST; CASE (%IFGT_OP); TRUTH = (ARG1.VALUE > ARG2.VALUE); CALL IF_TEST; CASE (%IFHAVE_OP); TRUTH = (IARG1.LOC = %CARRYING); CALL IF_TEST; CASE (%IFKEY_OP); IF (NPARAMS > 0 AND PARAM1.VALUE = IARG1.ADDRESS) OR (NPARAMS = 2 AND PARAM2.VALUE = IARG1.ADDRESS) THEN TRUTH = %YES#; ELSE TRUTH = %NO#; CALL IF_TEST; CASE (%IFLOC_OP); TRUTH = (IARG1.LOC = IARG2.ADDRESS); CALL IF_TEST; CASE (%IFLT_OP); TRUTH = (ARG1.VALUE < ARG2.VALUE); CALL IF_TEST; CASE (%IFNEAR_OP); IF IARG1.LOC = %CARRYING OR IARG1.LOC = HERE.VALUE OR (IARG1.BITS(%SCHIZOID_BIT) AND IARG1.LOC = HERE.VALUE - 1) THEN TRUTH = %YES#; ELSE TRUTH = %NO#; CALL IF_TEST; CASE (%INPUT_OP); CALL INPUT; TRAP_OCCURRED = %NO#; CASE (%ITLIST_OP); ITERATOR$ = ARG_PTRS.P1$; ITERATION_IC = NEXT_IC; ITERATION_TYPE = %ITERATE_OBJECTS_HERE; ITERATION_COUNT = HEADER_RECORD.NUMBER_OF_OBJECTS; ITERATOR.VALUE = %OBJECT_TYPE * 1000; CASE (%ITOBJECT_OP); ITERATOR$ = ARG_PTRS.P1$; ITERATION_IC = NEXT_IC; ITERATION_TYPE = %ITERATE_OBJECTS; ITERATION_COUNT = HEADER_RECORD.NUMBER_OF_OBJECTS; ITERATOR.VALUE = %OBJECT_TYPE * 1000; CASE (%ITPLACE_OP); ITERATOR$ = ARG_PTRS.P1$; ITERATION_IC = NEXT_IC; ITERATION_TYPE = %ITERATE_PLACES; ITERATION_COUNT = HEADER_RECORD.NUMBER_OF_PLACES; ITERATOR.VALUE = %PLACE_TYPE * 1000; CASE (%KEYWORD_OP); DO WHILE (CONTINUE_WITH_THIS_RECORD AND A_CODE.OPS(NEXT_IC) > %MAX_OPCODE); OP_CODE = A_CODE.OPS(NEXT_IC); NEXT_IC = NEXT_IC + 1; IF NPARAMS = 0 OR (OP_CODE ~= PARAM1.VALUE AND (NPARAMS = 1 OR OP_CODE ~= PARAM2.VALUE)) THEN CONTINUE_WITH_THIS_RECORD = %NO#; END; CASE (%LDA_OP); ARG1.VALUE = ARG2.ADDRESS; CASE (%LOCATE_OP); ARG1.VALUE = IARG2.LOC; CASE (%MOVE_OP); IF (NPARAMS = 1 AND ARG1.ADDRESS = PARAM1.VALUE) OR (NPARAMS = 2 AND PARAM2.VALUE = ARG1.ADDRESS AND (PARAM1.VALUE = GO_WORD OR (PARAM1.VALUE = SAY_WORD AND PARAM2.BITS(%VERB_BIT)))) THEN DO; CALL GO_TO (IARG2); ALTRETURN; END; CASE (%MULTIPLY_OP); ARG1.VALUE = ARG1.VALUE * ARG2.VALUE; CASE (%NAME_OP); SUB_VALUE = IARG2.VALUE; IF ARG2.ADDRESS = PARAM1.ADDRESS AND PARAMETER.LEN(1) > 0 THEN DO; SUB_STRING = PARAMETER.TEXT(1); SUB_LEN = PARAMETER.LEN(1); END; ELSE DO; IF ARG2.ADDRESS = PARAM2.ADDRESS AND PARAMETER.LEN(2) > 0 THEN DO; SUB_STRING = PARAMETER.TEXT(2); SUB_LEN = PARAMETER.LEN(2); END; ELSE DO; VALUE_SCAN.VALUE = IARG2.ADDRESS; CALL INDEX (I, VALUE_SCAN_STRING, VOCAB_TEXT) ALTRET (FAILED_TO_FIND_SYMBOL); ENTRY$ = PINCRC(VOCAB_AREA.PTR$, I); CALL INDEX (I, '$', VOCAB_ENTRY.NAME); CALL INDEX (SUB_LEN, '@', VOCAB_ENTRY.NAME); IF I = LENGTHC(VOCAB_ENTRY.NAME) AND SUB_LEN = LENGTHC(VOCAB_ENTRY.NAME) THEN DO; CALL GLITCH ('Malformed symbol table entry: record =/', RECORD, 'IC =/', IC, 'Symbol ID =/', IARG2.ADDRESS); SUB_LEN = 0; END; ELSE IF SUB_LEN > I THEN SUB_LEN = I; SUB_STRING = SUBSTR(VOCAB_ENTRY.NAME, 0, SUB_LEN); DO NEVER; FAILED_TO_FIND_SYMBOL: CALL GLITCH ('Unable to locate NAME symbol: record =/', RECORD, 'IC =/', IC, 'Symbol ID =/', IARG2.ADDRESS); SUB_LEN = 0; END; END; END; CALL SPEAK (IARG1); CASE (%NEAR_OP); DO WHILE (CONTINUE_WITH_THIS_RECORD AND A_CODE.OPS(NEXT_IC) > %MAX_OPCODE); OP_CODE = A_CODE.OPS(NEXT_IC); NEXT_IC = NEXT_IC + 1; IF (OP_CODE / 1000) = %VARIABLE_TYPE THEN OP_CODE = PINCRW(VARIABLE$, SIZEW(ARG) * MOD(OP_CODE, 1000)) -> ARG.VALUE; IF (OP_CODE / 1000) ~= %OBJECT_TYPE THEN CALL GLITCH ('Illegal "NEAR" - record =/', RECORD, 'IC =/', IC, 'operand =/', OP_CODE) ALTRET (TERMINATE_NEAR); ELSE DO; IARG_PTRS.P1$ = PINCRW(OBJECT$, MOD(OP_CODE, 1000) * SIZEW(ARG)); IF IARG1.LOC ~= %CARRYING AND IARG1.LOC ~= HERE.VALUE AND (NOT IARG1.BITS(%SCHIZOID_BIT) OR IARG1.LOC ~= HERE.VALUE - 1) THEN TERMINATE_NEAR: CONTINUE_WITH_THIS_RECORD = %NO#; END; END; CASE (%NOT_OP); NEGATE = %YES#; CASE (%OR_OP); CONNECTIVE = %OR_TRUTH; CASE (%PROCEED_OP); CONTINUE_WITH_THIS_RECORD = %NO#; CASE (%QUERY_OP); FLAG = (IF_LEVEL = 0); DO WHILE (FLAG); CALL SPEAK (IARG1); COMMAND = ' '; CALL M$READ (READ_SI) ALTRET (BAD_ANSWER); I = ASCBIN(SUBSTR(COMMAND, 0, 1)); IF I = ASCBIN('Y') OR I = ASCBIN('y') THEN DO; TRUTH = %YES#; FLAG = %NO#; END; ELSE IF I = ASCBIN('N') OR I = ASCBIN('n') THEN DO; TRUTH = %NO#; FLAG = %NO#; END; ELSE DO; MESSAGE = 'Please answer the question.'; CALL M$WRITE (WRITE_LO); END; END; TERMINAL_IO_ERROR = %NO#; CALL IF_TEST; DO NEVER; BAD_ANSWER: IF TERMINAL_IO_ERROR THEN CALL HANDLE_MONITOR_ERROR; ELSE DO; TERMINAL_IO_ERROR = %YES#; CALL M$RETRY; END; END; CASE (%QUIT_OP); ALTRETURN; CASE (%RANDOM_OP); CALL GET_RANDOM (I); ARG1.VALUE = MOD(I / 100, ARG2.VALUE); CASE (%SAY_OP); SUB_LEN = 0; SUB_VALUE = IARG1.VALUE; CALL SPEAK (IARG1); CASE (%SET_OP); ARG1.VALUE = ARG2.VALUE; CASE (%SMOVE_OP); IF (NPARAMS = 1 AND ARG1.ADDRESS = PARAM1.VALUE) OR (NPARAMS = 2 AND PARAM2.VALUE = ARG1.ADDRESS AND (PARAM1.VALUE = GO_WORD OR (PARAM1.VALUE = SAY_WORD AND PARAM2.BITS(%VERB_BIT)))) THEN DO; CALL GO_TO (IARG2); CALL SPEAK (IARG3); ALTRETURN; END; CASE (%STOP_OP); CALL M$EXIT; CASE (%SUB_OP); ARG1.VALUE = ARG1.VALUE - ARG2.VALUE; CASE (%SVARIABLE_OP); DO CASE (IARG1.VALUE); CASE (0); CALL M$DISPLAY (FPT_DISPLAY); I = VLR_DISPLAY.ETMF; CASE (1); CALL M$DISPLAY (FPT_DISPLAY); I = VLR_DISPLAY.RESP; CASE (2); CALL M$DISPLAY (FPT_DISPLAY); I = VLR_DISPLAY.USERS; CASE (4); CALL M$TIME (GET_DATE_AND_TIME); CALL CHARBIN (I, SUBSTR(DATE_INFO.TIME#, 0, 2)); CASE (5); CALL M$TIME (GET_DATE_AND_TIME); CALL CHARBIN (I, SUBSTR(DATE_INFO.TIME#, 3, 2)); CASE (6); CALL M$TIME (GET_DATE_AND_TIME); CALL CHARBIN (I, SUBSTR(DATE_INFO.TIME#, 6, 2)); CASE (8); I = BITBIN(B$JIT.SWITCH(ARG2.VALUE)); CASE (ELSE); I = 0; END; ARG2.VALUE = I; CASE (%VALUE_OP); SUB_VALUE = ARG2.VALUE; I = SUB_VALUE; SUB_LEN = 1; DO WHILE (I > 9); SUB_LEN = SUB_LEN + 1; I = I / 10; END; CALL BINCHAR (SUBSTR(SUB_STRING, 0, SUB_LEN), SUB_VALUE); CALL SPEAK (IARG1); CASE (ELSE); CALL GLITCH ('Bad opcode! Record =/', RECORD, 'IC =/', IC, 'Opcode =/', OP_CODE); END; END; IC = NEXT_IC; END; DO CASE (RECNO / 1000); CASE (%LABEL_TYPE, %INITIAL_TYPE, %REPEAT_TYPE); RETURN; CASE (ELSE); RECORD = RECORD + 1; END; END; FLUSH: ALTRETURN; WE_HAVE_TRAPPED: IF TRAP_OCCURRED THEN CALL M$ERR; TRAP_OCCURRED = %YES#; CALL M$CLRSTK; CALL GLITCH ('I trapped! Record =/', RECORD, 'IC =/', IC, 'Opcode =/', OP_CODE); ALTRETURN; %EJECT; EXECUTE_ACODE: ENTRY; I = 0; DO FOREVER; CALL PROCESS (I + %(INITIAL_TYPE * 1000)) ALTRET (DO_REAL); I = I + 1; END; DO_REAL: DO FOREVER; I = 0; DO FOREVER; CALL PROCESS (I + %(REPEAT_TYPE * 1000)) ALTRET (BAIL_OUT); I = I + 1; END; BAIL_OUT: END; END ACODE_INTERPRETER; %EOD; ACODE_TRAPPED: PROC ASYNC; /* We get here (via M$TRAP) if the ACODE interpreter traps during normal execution. We UNWIND to a REMEMBERed label in the hope that we can abort execution of the current sequence of commands and pick up at the first REPEAT. This sure ain't guaranteed to work, and the adventurer may find some inconsistancies in the cave after a trap occurs because the logic to move things to their proper places might not have been completed. */ DCL TRAP_RETURN BIT(72) DALIGNED SYMREF; UNWIND TO TRAP_RETURN; END ACODE_TRAPPED;